home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-driver.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  38.7 KB  |  1,055 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-driver.lisp
  3. ; Description:  Conversion to CL of the original Scheme program (by W. M Wells)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      10-Oct-90
  6. ; Modified:     Tue Aug  2 14:33:36 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ; 25-Apr-94 (Joachim H. Laubsch)
  17. ;  implemented state-sensitive token look-ahead
  18. ; 17-Aug-93 (Joachim H. Laubsch)
  19. ;  read-parser recognizes numbers: integer, ratio and float
  20. ;    <digit>* [ "." <digit>+ ]
  21. ;    <digit>+ "/" <digit>+
  22. ; the boolean id-allows-start-digit determines for a grammar whether an
  23. ; identifier may start with a digit.
  24. ; 22-Feb-93 (Joachim H. Laubsch)
  25. ;  if the grammar's intern-identifier attribute is true (default), an
  26. ;  Identifier will be represented as a symbol, otherwise a string
  27. ;  2-Feb-93 (Joachim H. Laubsch)
  28. ;  introduce the variable *case-sensitive* to deal with grammars whith
  29. ;  case-sensitive keywords
  30. ; 13-Jan-93 (Joachim H. Laubsch)
  31. ;  rewrote recognize-token so that (in ALL cases) keys that could start an
  32. ;  identifier will not be recognized as keys, but as identifiers.
  33. ; 27-Nov-92 (Joachim H. Laubsch)
  34. ;  Added Variable *preserve-case*
  35. ;  "If true, the case of an identifier will be preserved (default false)."
  36. ; 29-Sep-92 (Joachim H. Laubsch)
  37. ;  a one-character keyword is considered a token iff it is not
  38. ;  in identifier-start-chars or if the next character is not in
  39. ;  identifier-continue-chars
  40. ; 21-Jul-92 (Joachim H. Laubsch)
  41. ;  improved handling of NUMBER and IDENTIFIER in next-token
  42. ; 27-Apr-92 (Joachim H. Laubsch)
  43. ;  introduce *COMMENT-START*, a character that causes everything following
  44. ;      until the end-of-line to be ignored
  45. ;  introduce *COMMENT-BRACKETS*, a list of pairs of strings that designate
  46. ;      everything between them as to be ignored
  47. ; 22-Apr-92 (Joachim H. Laubsch)
  48. ;  define FILE-PARSER, a function like READ-PARSER that takes input
  49. ;  from a file instead of from a string
  50. ;  introduced :junk-allowed as argument to READ-PARSER with same meaning
  51. ;  as that keyword in READ-FROM-STRING
  52. ;  analogously in LIST-PARSER
  53. ; 15-Apr-92 (Joachim H. Laubsch)
  54. ;  introduce *IDENTIFIER-START-CHARS*
  55. ; 30-Oct-91 (Joachim H. Laubsch)
  56. ;  improved error checking in case a grammar does not use NUMBER, but the
  57. ;  parser will be given strings containing NUMBERs
  58. ; 16-Jul-91 (Joachim H. Laubsch)
  59. ;  Added a facility to deal with multiple grammars
  60. ;  lr-parse takes a third argument, a grammar
  61. ;  READ-PARSER and LIST-PARSER take a :grammar keyword argument, defaulting to
  62. ;  *current-grammar*
  63. ; 26-Jun-91 (Joachim H. Laubsch)
  64. ;  Added a proposal to distinguish String and Symbol-tokens in lexical analysis
  65. ;  of read-parser.  See comments with section
  66. ;         *string-delimiter*, *symbol-delimiter*
  67. ; 25-Apr-91 (Joachim H. Laubsch)
  68. ;  fixed bug in read-parser which caused scanner to break if a number was the
  69. ;  last constituent of a string
  70. ; 26-Mar-91 (Joachim H. Laubsch)
  71. ;  in the case where a keyword is found, but no action defined, we
  72. ;  assume it must be an identifier.  If there is an action entry for
  73. ;  an identifier, that identifier is interned from the keyword string read
  74. ; 26-Mar-91 (Joachim H. Laubsch)
  75. ;  make read-parser read these types of numbers: integer, float, rational
  76. ;  1-Mar-91 (Joachim H. Laubsch)
  77. ;  made various simple changes, based on monitoring results to speed up
  78. ;  READ-PARSER by a factor of 10
  79. ; 30-Jan-91 (Joachim H. Laubsch)
  80. ;  introduce variable: *string-delimiter*
  81. ; 17-Jan-91 (Joachim H. Laubsch)
  82. ;  introduced String syntax:  "Fred Jones" is a nll-constant
  83. ; 11-Dec-90 (Joachim H. Laubsch)
  84. ;  introduced the ZEBU package, and imported its exported symbols into USER
  85. ;  7-Dec-90 (Joachim H. Laubsch)
  86. ;  if a keyword ending in a symbol-continue-char is followed by a 
  87. ;  symbol-continue-char a keyword token is NOT recognized (but an identifier)
  88. ;  except if there would have been a single character keyword recognizing the 
  89. ;  same initial substring. E.g. ?u?foo1 is tokenized as ?u?, foo1, because
  90. ;  there is the shorter keyword alternative: ?, u?foo1
  91. ;  The principle is to give priority to the longest possible keyword.
  92. ;  (Note that agt007 or agt?x are recognized as identifiers)
  93. ; 27-Nov-90 (Joachim H. Laubsch)
  94. ;  Lexical Analysis (recognize-token) will recognize any keyword of the
  95. ;  language.  If lr-parse is given a token that is a keyword, it may not have
  96. ;  an action for it, but if this same token were regarded as an identifier,
  97. ;  there would be one.  Instead of reporting an error, lr-parse will now look 
  98. ;  first for the identifier-action.  
  99. ;    It would be best, if lr-parse could predict, whether an identifier is legal
  100. ;  in the current state and then direct recognize-token appropriately.  I should
  101. ;  come back to this, and implement that.  It would also save time.
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. ;;; Written by William M. Wells.  This is an example lr parser driver
  104. ;;; which uses parse table files generated by Zebu.  
  105.  
  106. (in-package "ZEBU")
  107.  
  108. (provide "zebu-driver")
  109. (require "zebu-loader")
  110. ;;;
  111. ;;; A rudimentary lr parser driver.
  112. ;;; It has provisions for applying client supplied procedures which are
  113. ;;; associated with productions in the grammar.
  114. ;;;
  115. ;;;
  116. ;;; This code is independent of the parse table generating system,
  117. ;;; and basically stand alone,  although
  118. ;;; it needs some macros defined in other files.
  119. ;;;
  120. (defvar *CURRENT-GRAMMAR* *NULL-Grammar*)
  121.  
  122. (defvar *terminal-alist-SEQ*)
  123.  
  124. (defvar *lexer-debug* nil)
  125. (eval-when (compile)
  126.   (setq *lexer-debug* nil))
  127.  
  128. #|
  129. (setq *lexer-debug* t)
  130. |#
  131.  
  132. (defmacro if-debugging-lexer (then &optional else)
  133.   `,(if *lexer-debug* then else))
  134.  
  135. (if-debugging
  136.  (defmacro say-looking-at ()
  137.    '(format t "~%Looking-at: ~S . ~a {~s}"
  138.      input-symbol-instantiation
  139.      (let ((a (svref (grammar-lexicon grammar) input-symbol-index)))
  140.        (if (symbolp a) (format nil "<~a>" (symbol-name a)) a))
  141.      input-symbol-index)))
  142.  
  143. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  144. ;;                                  utilities
  145. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  146. ;; (upcased-subseq string from to) == (string-upcase (subseq string from to))
  147. ;; but avoids a copy
  148. (defun upcased-subseq (string beg end)
  149.   (declare (simple-string string) (fixnum beg end))
  150.   (let* ((size (- end beg))
  151.      (R (make-sequence 'simple-string size))
  152.      (stringi beg))
  153.     (declare (simple-string R) (fixnum stringi))
  154.     (dotimes (index size)
  155.       (setf (schar R index) (char-upcase (the character (schar string stringi))))
  156.       (incf stringi))
  157.     R))
  158.  
  159. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  160. ;;                             The LR parser itself
  161. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  162.  
  163. ;;; symbol-stack and state-stack are the standard things for an lr parser.
  164. ;;; the client lambdas and stack are used in the following fashion:
  165. ;;;
  166. ;;;   When a shift action occurs, the instantiation of the input symbol
  167. ;;;   is pushed onto the client stack.
  168. ;;;
  169. ;;;   When a reduce action occurs, as many items as are on the lhs
  170. ;;;   of the associated production are popped from the client stack
  171. ;;;   and the corresponding client lambda is applied to the popped
  172. ;;;   items.  The result of the application is then pushed onto the 
  173. ;;;   client stack.  One may of course do whatever one wishes by side
  174. ;;;   effect.
  175.  
  176. ;;; when junk-allowed, 2 values are returned:
  177. ;;;         the object found so far
  178. ;;;         the value returned by last-pos-fn
  179. ;;; last-pos-fn should be defined as a function that returns the place
  180. ;;;         before the token just returned by next-token-fn
  181.  
  182. ;;; when more-allowed, no "<end of string>" error is issued but
  183. ;;; more-fn is called to extend the token-stream that next-token-fn is
  184. ;;; using.
  185.  
  186. (defun lr-parse (next-token-fn error-fn grammar
  187.                    &optional junk-allowed last-pos-fn
  188.                    &aux symbol-stack client-stack state-stack
  189.                    action-table-top state-stack-top)
  190.   (declare #+(or :MCL :ANSI-COMMON-LISP)
  191.        (dynamic-extent symbol-stack client-stack state-stack)
  192.        (type cons symbol-stack client-stack state-stack)
  193.        (type grammar grammar)
  194.        (function next-token-fn (simple-vector) t fixnum)
  195.        (function error-fn (string) error))
  196.   (let ((start-state (grammar-lr-parser-start-state-index grammar))
  197.     (production-info (grammar-production-info grammar))
  198.     (action-table (grammar-action-table grammar))
  199.     (goto-table (grammar-goto-table grammar))
  200.     (client-lambdas (grammar-client-lambdas grammar))
  201.     (end-symbol-index (grammar-end-symbol-index grammar))
  202.     action-entry)
  203.     (declare (fixnum end-symbol-index)
  204.          (simple-vector action-table goto-table))
  205.     (push start-state state-stack)
  206.     (setf state-stack-top start-state
  207.       action-table-top (svref action-table start-state))
  208.     (multiple-value-bind (input-symbol-instantiation input-symbol-index)
  209.     (funcall next-token-fn action-table-top)
  210.       (if-debugging (say-looking-at))
  211.       (setf action-entry (vec-bs-assoc (the fixnum input-symbol-index)
  212.                        action-table-top))
  213.       (loop
  214.        (when (null action-entry)
  215.      (if (eq input-symbol-index end-symbol-index)
  216.          (funcall error-fn
  217.               (undef-action-error input-symbol-instantiation
  218.                       input-symbol-index
  219.                       action-table-top
  220.                       grammar))
  221.        (unless (and junk-allowed
  222.             ;; assume that EOF was seen
  223.             (setq action-entry 
  224.                   (vec-bs-assoc
  225.                    end-symbol-index action-table-top)))
  226.          (or (let ((idx (grammar-identifier-index grammar)))
  227.            (and (setf action-entry (vec-bs-assoc idx action-table-top))
  228.             (stringp input-symbol-instantiation)
  229.             (not (string=
  230.                   (the string input-symbol-instantiation) ""))
  231.             (identifier-start-char-p
  232.              (schar input-symbol-instantiation 0))
  233.             (not (find-if-not #'identifier-continue-char-p
  234.                       input-symbol-instantiation
  235.                       :start 1))
  236.             (setq input-symbol-instantiation
  237.                   (if (grammar-intern-identifier grammar)
  238.                   (intern
  239.                    (if *preserve-case*
  240.                        (the string input-symbol-instantiation)
  241.                      (string-upcase
  242.                       (the string input-symbol-instantiation))))
  243.                 input-symbol-instantiation)
  244.                   input-symbol-index idx)))
  245.          (funcall error-fn
  246.               (undef-action-error input-symbol-instantiation
  247.                           input-symbol-index
  248.                           action-table-top
  249.                           grammar))))))       
  250.        ;; there should always be a non null action-entry !!
  251.        (let ((ae-cdr (cdr (the cons action-entry))))
  252.      (case (car (the cons ae-cdr))
  253.        (:S                ; Shift.
  254.         (setf state-stack-top (cadr ae-cdr) ; new-state
  255.           action-table-top (svref action-table state-stack-top))
  256.         (push state-stack-top state-stack)
  257.         (if-debugging (format t "~%Shift to ~S" state-stack-top))
  258.         (push input-symbol-index symbol-stack)
  259.         (push input-symbol-instantiation client-stack)
  260.         (multiple-value-setq
  261.         (input-symbol-instantiation input-symbol-index)
  262.           (funcall next-token-fn action-table-top))
  263.         (if-debugging (say-looking-at))
  264.         (setf action-entry (vec-bs-assoc (the fixnum input-symbol-index)
  265.                          action-table-top)))
  266.        (:R                ; Reduce.
  267.         (let* ((prod-index (cadr ae-cdr))
  268.            (p (svref production-info prod-index))
  269.            ;; p = <lhs-symbol-index> . <production-length>
  270.            (prod-lhs (car (the cons p)))
  271.            (prod-ln (cdr (the cons p)))
  272.            (client-lambda (svref client-lambdas prod-index)))
  273.           (if-debugging (format t "~%Reduce ~S" prod-index))
  274.           ;; optimize simple cases
  275.           (case prod-ln
  276.         (0            ; Apply the client lambda and store the result.
  277.          (if-debugging (format t "~%; Calling ~S" client-lambda))
  278.          (push (funcall client-lambda) client-stack)
  279.          (if-debugging 
  280.           (let ((R (car client-stack)))
  281.             (format t "~%; -> ~S : ~S" R (type-of R)))))
  282.         (1            ; Apply the client lambda and store the result.
  283.          (when client-lambda
  284.            (if-debugging (format t "~%; Applying ~S to ~S"
  285.                      client-lambda (car client-stack)))
  286.            (setf (car client-stack)
  287.              (funcall client-lambda (car client-stack)))
  288.            (if-debugging 
  289.             (let ((R (car client-stack)))
  290.               (format t "~%; -> ~S : ~S" R (type-of R)))))
  291.          (setq symbol-stack (cdr symbol-stack)
  292.                state-stack  (cdr state-stack)
  293.                ))
  294.         (2            ; Apply the client lambda and store the result.
  295.          (if-debugging (format t "~%; Applying ~S to ~{ ~s~}"
  296.                        client-lambda (subseq client-stack 0 2)))
  297.          (when client-lambda
  298.            (let* ((arg2 (pop client-stack))
  299.               (R (funcall client-lambda
  300.                       (car client-stack)
  301.                       arg2)))
  302.              (setf (car client-stack) R)))
  303.          (setq symbol-stack (cddr symbol-stack)
  304.                state-stack  (cddr state-stack))
  305.          (if-debugging 
  306.           (let ((R (car client-stack)))
  307.             (format t "~%; -> ~S : ~S" R (type-of R)))))
  308.         (t (let (constituents)
  309.              (dotimes (i prod-ln) 
  310.                (setq symbol-stack (cdr symbol-stack)
  311.                  state-stack  (cdr state-stack))
  312.                (push (pop client-stack) constituents))
  313.              ;; Apply the client lambda and store the result.
  314.              (if-debugging (format t "~%; Applying ~S to ~S"
  315.                        client-lambda constituents))
  316.              (push (apply client-lambda ; action
  317.                   constituents)
  318.                client-stack)
  319.              (if-debugging 
  320.               (let ((R (car client-stack)))
  321.             (format t "~%; -> ~S : ~S" R (type-of R)))))))
  322.           (push prod-lhs symbol-stack) ; Push lhs of production.
  323.           (let ((goto (cdr (the cons
  324.                     (vec-bs-assoc
  325.                      prod-lhs
  326.                      (svref goto-table (car state-stack)))))))
  327.         (if (null goto) 
  328.             (funcall error-fn "table error? goto not defined!"))
  329.         (push goto state-stack)
  330.         (setf state-stack-top goto ; new-state
  331.               action-table-top (svref action-table state-stack-top)
  332.               action-entry (vec-bs-assoc
  333.                     (the fixnum input-symbol-index)
  334.                     action-table-top))
  335.         )))
  336.        (:A
  337.         ;; Accept on END symbol.
  338.         (if-debugging (format t "~%Accepting"))
  339.         ;; (break "Accept ~s" input-symbol-index)
  340.         (if junk-allowed
  341.         (return
  342.           (values (car client-stack)
  343.               (when last-pos-fn (funcall last-pos-fn))))
  344.           (if (= input-symbol-index end-symbol-index)
  345.           (return
  346.             (values (car client-stack)
  347.                 (when last-pos-fn (funcall last-pos-fn))))
  348.         (if (eq input-symbol-instantiation T)
  349.             (funcall error-fn "Unexpected token")
  350.           (funcall error-fn "extra input?")))))
  351.        (T (funcall error-fn
  352.                (format nil
  353.                    "Bogus action: ~S" (car ae-cdr))))))))))
  354.  
  355. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  356. ;;                                   Errors
  357. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  358.  
  359. (defun possible-tokens (expected lexicon)
  360.   (if expected
  361.       (let ((tokenL (map 'list
  362.              #'(lambda (action) 
  363.                  (let ((a (svref lexicon (car action))))
  364.                    (if (symbolp a)
  365.                    (format nil "<~a>" (symbol-name a))
  366.                  (format nil "~s" a))))
  367.              expected)))
  368.     (format
  369.      nil "~%Expected~:[ one of~;~]:~{ ~a~}~%"
  370.      (= 1 (length tokenL)) tokenL))
  371.     ""))
  372.  
  373. (defun unrecognized-token-error (string pos expected grammar)
  374.   (let ((lexicon (grammar-lexicon grammar)))
  375.     (concatenate 'string
  376.          (format nil "Unrecognized Token at: ~s"
  377.              (subseq string pos))
  378.          (possible-tokens expected lexicon))))
  379.  
  380. (defun undef-action-error (token index expected grammar)
  381.   (let* ((lexicon (grammar-lexicon grammar))
  382.      (type (if index
  383.            (let ((e (svref lexicon index)))
  384.              (if (symbolp e)
  385.              (format nil "<~a>" (symbol-name e))
  386.                "KEY")))))
  387.     (format
  388.      nil "Syntax error (action not defined for token: ~S~@[ a ~a~])~a"
  389.      token type (possible-tokens expected lexicon))))
  390.  
  391.  
  392. ;;; A function for looking up table entries using binary search
  393. ;;; the vector elements are the assoc key and should be in increasing order.
  394. #||
  395. (defun vec-bs-assoc (num vec)
  396.   (declare (type fixnum num) (type vector vec))
  397.   (labels ((vec-bs-assoc-aux (start end)
  398.          (declare (type fixnum start end))
  399.          (let ((start-entry (svref vec start)))
  400.            (declare (type cons start-entry))
  401.            (cond ((= num (the fixnum (car start-entry))) start-entry)
  402.              ((= start end) nil)
  403.              (T (let ((mid (floor (+ start end) 2)))
  404.               (declare (type fixnum mid))
  405.               (if (> num (the fixnum (car (svref vec mid))))
  406.                   (vec-bs-assoc-aux (1+ mid) end)
  407.                 (vec-bs-assoc-aux start mid))))))))
  408.     (let ((last (1- (length (the vector vec)))))
  409.       (declare (type fixnum last))
  410.       (if (or (< num (the fixnum (car (svref vec 0))))
  411.           (> num (the fixnum (car (svref vec last)))))
  412.       nil
  413.     (vec-bs-assoc-aux 0 last)))))
  414. ||#
  415. #-ALLEGRO
  416. (defun vec-bs-assoc (num vec)
  417.   (declare (type fixnum num) (type simple-vector vec))
  418.   (labels ((vec-bs-assoc-aux (start end)
  419.          (declare (type fixnum start end))
  420.          (let ((start-entry (svref vec start)))
  421.            (declare (type cons start-entry))
  422.            (cond ((= num (the fixnum (car start-entry))) start-entry)
  423.              ((= start end) nil)
  424.              (T (let ((mid (floor (+ start end) 2)))
  425.               (declare (type fixnum mid))
  426.               (if (> num (the fixnum (car (svref vec mid))))
  427.                   (vec-bs-assoc-aux (1+ mid) end)
  428.                 (vec-bs-assoc-aux start mid))))))))
  429.     (let ((vln (length vec)))
  430.       (declare (type fixnum vln))
  431.       (if (zerop vln)
  432.       nil
  433.     (let ((last (1- vln)))
  434.       (declare (type fixnum last))
  435.       (if (zerop last)
  436.           (let ((entry (svref vec last)))
  437.         (declare (cons entry))
  438.         (when (= num (the fixnum (car entry)))
  439.           entry))
  440.         (vec-bs-assoc-aux 0 last)))))))
  441.  
  442. #+ALLEGRO 
  443. ; konrad@dfki.uni-sb.de writes:
  444. ; man kann den Speicherbedarf von Zebu muehelos um mehr als 40%
  445. ; reduzieren, wenn man in zebu-driver die Definition von vec-bs-aux in
  446. ; folgendes veraendert:
  447.  
  448. (progn
  449.   (defparameter *bs-vec* nil)
  450.   (defparameter *bs-num* nil)
  451.  
  452.   (defun vec-bs-assoc-aux (start end)
  453.     (declare (type fixnum start end))
  454.     (let ((start-entry (svref *bs-vec* start)))
  455.       (declare (type cons start-entry))
  456.       (cond ((= *bs-num* (the fixnum (car start-entry))) start-entry)
  457.         ((= start end) nil)
  458.         (T (let ((mid (floor (+ start end) 2)))
  459.          (declare (type fixnum mid))
  460.          (if (> *bs-num* (the fixnum (car (svref *bs-vec* mid))))
  461.              (vec-bs-assoc-aux (1+ mid) end)
  462.            (vec-bs-assoc-aux start mid)))))))
  463.  
  464.   (defun vec-bs-assoc (num vec)
  465.     (declare (type fixnum num) (type simple-vector vec))
  466.     (setq *bs-vec* vec *bs-num* num)
  467.     (vec-bs-assoc-aux 0 (1- (length vec))))
  468.   )
  469.  
  470.  
  471. ;;; Figure out to which element of the lexicon a token corresponds.
  472. ;;; This gets a little complicated for terminal symbols which can
  473. ;;; vary at parsing time, for example, identifiers and numbers.  The way
  474. ;;; these "preterminals" are handled in this driver is as follows:
  475. ;;; If a token passes the CL test PARSE-NUMBER, and the argument number-index
  476. ;;; isn't false, then number-index is treated as representing its category.
  477. ;;; Otherwise, if the token appears exactly in the lexicon, then it is
  478. ;;; given the category of the lexicon item.  Otherwise it is assumed
  479. ;;; to be an instance of the terminal IDENTIFIER, whose presence in the
  480. ;;; lexicon is indicated by a non false value for the id-index argument.
  481. ;;; If the token isn't explicitly in the lexicon, and id-index is false,
  482. ;;; then an error is signalled.
  483. ;;; 
  484.  
  485.  
  486. ;;; number-index should be the index of the grammar symbol which stands
  487. ;;; for numbers, otherwise it should be false if numbers don't appear
  488. ;;; in the grammar.
  489. ;;;
  490. ;;; id-index should be the index of the grammar symbol which stands
  491. ;;; for identifiers, otherwise it should be false if identifiers don't
  492. ;;; appear in the grammar.
  493.  
  494.  
  495. (defun categorize (token grammar)
  496.   (let ((category 
  497.      (if (numberp token)
  498.          (progn (if-debugging
  499.              (assert (grammar-number-index grammar) ()
  500.                  "A number was seen in the token stream"))
  501.             (grammar-number-index grammar))
  502.            (let ((terminal-associations
  503.           (elt (grammar-terminal-alist-SEQ grammar)
  504.                (char-code (let ((c (schar (string token) 0)))
  505.                     (declare (character c))
  506.                     (if (grammar-case-sensitive grammar)
  507.                     c
  508.                       (char-downcase c)))))))
  509.              (if terminal-associations
  510.          (let ((terminal-association (assoc token terminal-associations
  511.                             :test #'equal)))
  512.            (if terminal-association
  513.                (cdr terminal-association)
  514.              (grammar-identifier-index grammar)))
  515.            (grammar-identifier-index grammar))))))
  516.     (values token category)))
  517.  
  518. (declaim (inline end-of-tokens-category))
  519. (defun end-of-tokens-category (grammar)
  520.   (values Nil (grammar-end-symbol-index grammar)))
  521.  
  522. (declaim (inline unrecognized-token-category))
  523. (defun unrecognized-token-category (grammar)
  524.   (values T (grammar-end-symbol-index grammar)))
  525.  
  526. ;;; This implements a parser which gets its tokens from the supplied list.
  527. ;;; It uses the parsing engine lr-parse which is defined above.  It also
  528. ;;; uses the function categorize to classify tokens according to the 
  529. ;;; lexicon.
  530.  
  531. (defun list-parser (token-list &key (grammar *current-grammar*) junk-allowed)
  532.   (let ((last-position token-list)
  533.         token1 category)
  534.     (flet ((list-parser-error (string)
  535.          (error "~a~% Remaining tokens: ~S~{ ~S~}"
  536.             string token1 token-list)))
  537.       (check-type token-list list)
  538.       (lr-parse
  539.        ;; This lambda is the tokenizer supplied to the parsing engine:
  540.        #'(lambda (&optional ignore)
  541.        (declare (ignore ignore))
  542.        (if (null token-list)
  543.            (end-of-tokens-category grammar)
  544.          (progn
  545.            (setq last-position token-list)
  546.            (multiple-value-setq (token1 category)
  547.          (categorize (pop token-list) grammar))
  548.            (if (null category)
  549.            (if junk-allowed
  550.                (unrecognized-token-category grammar)
  551.              (list-parser-error 
  552.             (format nil "Unrecognized Token ~s" token1)))
  553.          (values token1 category)))))
  554.        ;; This is the error function supplied to the parsing engine:
  555.        #'list-parser-error
  556.        grammar
  557.        junk-allowed
  558.        ;; Function that returns the remaining unparsed token-list
  559.        #'(lambda () last-position)))))
  560.     
  561. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  562. ;;                                 read-parser
  563. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  564.  
  565. ;;; This implements a parser which gets its tokens from the Lisp function
  566. ;;; read.
  567. ;;; It uses the parsing engine lr-parse which is defined above.  It also
  568. ;;; uses the function categorize to classify tokens according to the 
  569. ;;; lexicon.  It will signal the end of input to the parser when it
  570. ;;; if it reads the end of file.
  571.  
  572. (defun read-parser (string &key
  573.                (error-fn #'(lambda (msg) (error "~a" msg)))
  574.                (print-parse-errors t)
  575.                (grammar *current-grammar*)
  576.                (start 0)
  577.                junk-allowed
  578.                more-allowed
  579.                more-fn)
  580.   (declare (string string))
  581.   (check-type string string)
  582.   (check-type grammar grammar)
  583.   (let ((number-index (grammar-number-index grammar))
  584.     (identifier-index (grammar-identifier-index grammar))
  585.     (string-index (grammar-string-index grammar))
  586.     (string-ln (length (the string string)))
  587.     (last-pos 0)
  588.     (pos start)
  589.     (end-symbol-index (grammar-end-symbol-index grammar))
  590.     (*identifier-start-chars-V* (grammar-identifier-start-chars-V grammar))
  591.     (id-allows-start-digit (grammar-id-allows-start-digit grammar))
  592.     (*identifier-continue-chars-V* (grammar-identifier-continue-chars-V grammar))
  593.     (*terminal-alist-SEQ* (grammar-terminal-alist-SEQ grammar))
  594.     (intern-identifier (grammar-intern-identifier grammar))
  595.     (white-space      (grammar-white-space grammar))
  596.     (string-delimiter (grammar-string-delimiter grammar))
  597.     (symbol-delimiter (grammar-symbol-delimiter grammar))
  598.     (lex-cat-map (grammar-lex-cat-map grammar))
  599.     (*case-sensitive* (grammar-case-sensitive grammar))
  600.     token find-id? find-string?)
  601.     (declare (fixnum string-ln pos last-pos)
  602.          (special *identifier-continue-chars-V*
  603.               *identifier-start-chars-V*))
  604.     (flet ((white-space-p (char)
  605.          (member (the character char) white-space
  606.              :test #'char=))
  607.        (digit-seq? (dec end)
  608.          (and dec
  609.           (or (>= end string-ln)
  610.               (and (not id-allows-start-digit)
  611.                (not (identifier-continue-char-p
  612.                  (schar string end)))))))
  613.        (new-fraction (num den places)
  614.          (values (float (+ num (/ den (expt 10 places))))
  615.              number-index))
  616.        )
  617.       ;; The tokenizer supplied to the parsing engine:       
  618.       (flet
  619.       ((next-token (actionv)
  620.          (if-debugging
  621.           (format t "~%~a"
  622.               (possible-tokens actionv (grammar-lexicon grammar))))
  623.          (loop 
  624.           ;; skip initial blanks
  625.           (setq last-pos pos
  626.             pos (or (position-if-not #'white-space-p string :start pos)
  627.                 string-ln))
  628.           ;; end of string?
  629.           (when (< pos string-ln) (return nil))
  630.           (unless (and more-allowed more-fn) (return nil))
  631.           (setq string
  632.             (funcall 
  633.              more-fn
  634.              #'(lambda ()
  635.              (if (find end-symbol-index actionv
  636.                    :key #'car)
  637.                  (return-from next-token
  638.                    (values nil end-symbol-index))
  639.                (return-from read-parser
  640.                  (funcall
  641.                   error-fn
  642.                   (unrecognized-token-error
  643.                    "<end of string>" 0 actionv grammar))))))
  644.             string-ln (length string)
  645.             pos       0
  646.             last-pos  0))
  647.          (when (>= pos string-ln)
  648.            (if (find end-symbol-index actionv
  649.              :key #'car)
  650.            (return-from next-token
  651.              (values nil end-symbol-index))
  652.          (return-from read-parser
  653.            (funcall
  654.             error-fn
  655.             (unrecognized-token-error
  656.              "<end of string>" 0 actionv grammar)))))
  657.  
  658.          ;; is an IDENTIFIER also expected
  659.          (setf find-id? (and identifier-index
  660.                  (find identifier-index actionv
  661.                        :key #'car)))
  662.          ;; scan lexical categories (regular expressions) first
  663.          (dolist (lex-cat-pair lex-cat-map)
  664.            (let ((lex-cat (car lex-cat-pair)))
  665.          (when (find lex-cat actionv :key #'car)
  666.            (let ((new-pos (funcall (the function (cdr lex-cat-pair))
  667.                        string pos string-ln)))
  668.              (if-debugging-lexer
  669.               (format t "~% calling ~s" (cdr lex-cat-pair)))
  670.              (when
  671.              (and
  672.                new-pos
  673.                ;; a match is found, and it could NOT be a 
  674.                ;; possibly longer identifier
  675.                (or 
  676.                 (not find-id?)
  677.                 (not
  678.                  (and (< new-pos string-ln)
  679.                   ;; if a identifier-continue-char doesn't
  680.                   ;; follow, we also accept
  681.                   (identifier-continue-char-p
  682.                    (schar string new-pos))
  683.                   ;; the token starts with
  684.                   ;; an identifier-start-char
  685.                   (identifier-start-char-p
  686.                    (schar string pos))
  687.                   ;; all of the remaining chars 
  688.                   ;; continue an identifier
  689.                   (let ((p1 (1+ pos)))
  690.                     (declare (fixnum p1))
  691.                     (or (= p1 new-pos)
  692.                     (not (find-if-not
  693.                           #'identifier-continue-char-p
  694.                           string
  695.                           :start p1 :end new-pos))))))))
  696.                (let ((instance (subseq string pos new-pos)))
  697.              (setq pos new-pos)
  698.              (if-debugging
  699.               (format t "~%LexToken: ~s : ~s ~s < ~s" instance (car lex-cat-pair) new-pos string-ln)) 
  700.              (return-from next-token
  701.                (values instance lex-cat))))))))
  702.  
  703.          ;; read symbol, string, or number
  704.          ;; foo : symbol, 'foo' : symbol, "foo" : string, 3/4 : number
  705.          ;; recognize a number: <digit>* [ "." <digit>+ ]
  706.          ;;                     <digit>+ "/" <digit>+
  707.          (when (and number-index (find number-index actionv :key #'car))
  708.            (multiple-value-bind (number end)
  709.            (parse-integer string :start pos :junk-allowed t)
  710.          (if (not number)
  711.              ;; the case .<integer>
  712.              (when (and (eql (schar string pos) '#\.)
  713.                 (DIGIT-CHAR-P (schar string (1+ pos))))
  714.                (multiple-value-bind (dec end)
  715.                (parse-integer string
  716.                       :start (1+ pos) :junk-allowed t)
  717.              (when (digit-seq? dec end)
  718.                (let ((places (- end (1+ pos))))
  719.                  (setq pos end)
  720.                  (return-from next-token
  721.                    (new-fraction 0 dec places))))))
  722.            (progn
  723.              (when (>= end string-ln)
  724.                (setq pos end)
  725.                (return-from next-token (values number number-index)))
  726.              (let ((c (schar string end)) (p (1+ end)))
  727.                (case c
  728.              (#\/ (multiple-value-bind (denom end)
  729.                   (parse-integer string
  730.                          :start p :junk-allowed t)
  731.                 (when denom
  732.                   (setq pos end)
  733.                   (return-from next-token
  734.                     (values (/ number denom) number-index))))
  735.                   (setq pos end)
  736.                   (return-from next-token
  737.                 (values number number-index)))
  738.              (#\. (multiple-value-bind (dec end)
  739.                   (parse-integer string
  740.                          :start p :junk-allowed t)
  741.                 (when dec
  742.                   (let ((places (- end p)))
  743.                     (setq pos end)
  744.                     (return-from next-token
  745.                       (new-fraction number dec places)))))
  746.                   (setq pos p)
  747.                   (return-from next-token
  748.                 (values number number-index)))
  749.              (t (when (or (not id-allows-start-digit)
  750.                       (not (identifier-continue-char-p c)))
  751.                   (setq pos end)
  752.                   (return-from next-token
  753.                 (values number number-index))))))))))
  754.          ;; recognize a grammar keyword
  755.          (multiple-value-bind (token-association token-length)
  756.          (recognize-kwd string pos string-ln actionv find-id?)
  757.            (when token-association
  758.          ;; token recognized
  759.          (setq pos (+ pos token-length)
  760.                token (car token-association))
  761.          (return-from next-token
  762.            (values token (cdr token-association)))))
  763.          ;; recognize an identifier or string
  764.          (setf find-string? (and string-index
  765.                      (find string-index actionv
  766.                        :key #'car)))
  767.          (when (or find-id? find-string?)
  768.            (let ((char (schar string pos)) c)
  769.          (declare (character char c))
  770.          (flet ((parse-delimited-id (delimiter symb?)
  771.               ;; when successful set token and pos!!
  772.               (flet ((eof-error ()
  773.                    (return-from read-parser
  774.                      (funcall
  775.                       error-fn
  776.                       (format
  777.                        nil "Closing ~:[String~;Symbol~] delimiter ~S expected"
  778.                        symb? delimiter)))))
  779.                 (when (char= char delimiter)
  780.                   (do ((p (incf pos) (1+ p))
  781.                    (escaped? nil (char= c #\\)))
  782.                   (nil)
  783.                 (declare (fixnum p))
  784.                 (when (= p string-ln)
  785.                   (if more-fn
  786.                       (setq string
  787.                         (concatenate
  788.                          'string
  789.                          string (string #\Newline)
  790.                          (funcall more-fn #'eof-error))
  791.                         string-ln (length string))
  792.                     (eof-error)))
  793.                 (setq c (schar string p))
  794.                 (when (and (char= c delimiter)
  795.                        (not escaped?))
  796.                   (setq token (subseq string pos p)
  797.                     pos (1+ p))
  798.                   (return-from parse-delimited-id t)))))))
  799.            (and find-id?
  800.             (parse-delimited-id symbol-delimiter t)
  801.             (return-from next-token
  802.               (values (intern token) identifier-index)))
  803.            (and find-string?
  804.             (parse-delimited-id string-delimiter nil)
  805.             (return-from next-token
  806.               (values token string-index))))
  807.  
  808.          ;; Does char start an identifier?
  809.          (unless find-id? (funcall error-fn (unrecognized-token-error
  810.                              string pos actionv grammar)))
  811.          (flet ((parse-id ()
  812.               ;; Any char not in *identifier-continue-chars* terminates
  813.               (do ((p (1+ pos) (1+ p))) 
  814.                   ((or (= p string-ln)
  815.                    (not (identifier-continue-char-p (schar string p))))
  816.                    (prog1 (if *preserve-case*
  817.                       (subseq string pos p)
  818.                     (upcased-subseq string pos p))
  819.                  (setq pos p)))
  820.                 (declare (fixnum p)))))
  821.            (let ((Id-String
  822.               (block Identifier
  823.                 (when (identifier-start-char-p char)
  824.                   (let ((id1 (parse-id)))
  825.                 (when (or (= pos string-ln)
  826.                       (char/= (schar string pos) #\:)
  827.                       *disallow-packages*)
  828.                   (return-from Identifier id1))
  829.                 ;; more chars follow the ":" ?
  830.                 (let ((package (find-package id1)))
  831.                   (unless package
  832.                     (return-from Identifier id1))
  833.                   ;; <package-symbol>: ...
  834.                   (let* ((p (1+ pos))
  835.                      (next (schar string p)))
  836.                     (when (char= next #\:)
  837.                       (setq next (schar string (incf p))))
  838.                     (unless (identifier-start-char-p next)
  839.                       (return-from Identifier id1))
  840.                     (setq pos p)
  841.                     (return-from next-token
  842.                       (values
  843.                        (intern (the simple-string (parse-id)) package)
  844.                        identifier-index)
  845.                       )))))
  846.                 ;; Symbol in keyword package ?
  847.                 (when (and (char= char #\:)
  848.                        (identifier-start-char-p
  849.                     (schar string (incf pos))))
  850.                   (return-from next-token
  851.                 (values (intern (the simple-string
  852.                              (parse-id))
  853.                         *keyword-package*)
  854.                     identifier-index))))))
  855.              (when Id-String
  856.                (return-from next-token
  857.              (values (if intern-identifier
  858.                      (intern Id-String) Id-String)
  859.                  identifier-index)))))))
  860.          (if (and junk-allowed
  861.               (find end-symbol-index actionv :key #'car))
  862.          (return-from next-token (values nil end-symbol-index))
  863.            ;; none of the symbols that we are looking for found
  864.            (funcall error-fn (unrecognized-token-error
  865.                   string pos actionv grammar)))))
  866.     (lr-parse
  867.      (if-debugging-lexer        ;  for testing
  868.       #'(lambda (a)
  869.           (multiple-value-bind (token id)
  870.           (next-token a)
  871.         (format t "~%New Token: ~S . ~S Pos: ~S"
  872.             token id pos)
  873.         (values token id)))
  874.       #'next-token)
  875.      ;; This is the error function supplied to the parsing engine:
  876.      #'(lambda (msg)
  877.          (when print-parse-errors
  878.            (format t "~%Last token read: ~S~%Remaining: ~A~@[~A ...~]~%"
  879.                token
  880.                (subseq string pos)
  881.                (when more-allowed (funcall more-fn))))
  882.          (funcall error-fn msg))
  883.      grammar
  884.      junk-allowed
  885.      #'(lambda () last-pos))))))
  886.  
  887. ;----------------------------------------------------------------------------;
  888. ; recognize-kwd
  889. ;--------------
  890. ; 
  891. (defun recognize-kwd (string pos string-length actionv find-id?)
  892.   ;; Does any of the terminal symbols of the grammar start STRING at POS?
  893.   ;; In case it does, it must be the longest one
  894.   ;; the ordering of terminal-alist makes sure we find the longest keyword
  895.   ;; first
  896.   (declare (string string) (fixnum string-length))
  897.   (let ((max-token-length (- string-length (the integer pos))))
  898.     (declare (fixnum max-token-length))
  899.     (flet ((recognize-kwd-aux (ta)
  900.          (do ((ta-rest ta (cdr (the cons ta-rest))))
  901.          ((null ta-rest) nil)
  902.            ;; (break "recognize-kwd: ~s ~%~s" actionv ta-rest)
  903.            (let ((token-association (car (the cons ta-rest))))
  904.          (when (find (cdr token-association) actionv :key #'car)
  905.            ;; search only for a legitimite keyword
  906.            (let* ((terminal-token (car token-association))
  907.               (token-length (length (the string terminal-token))))
  908.              (declare (fixnum token-length) (string terminal-token))
  909.              (and (>= max-token-length token-length)
  910.               (let ((string-end (+ pos token-length)))
  911.                 (declare (fixnum string-end))
  912.                 (and (if *case-sensitive*
  913.                      (string= terminal-token string
  914.                           :start2 pos :end2 string-end)
  915.                    (string-equal terminal-token string
  916.                          :start2 pos :end2 string-end))
  917.                  ;; 
  918.                  ;; If we recognize a keyword, that could start
  919.                  ;; an identifier, the following char must
  920.                  ;; not also be a symbol-continue-char.
  921.                  ;; If it is (e.g. "agent1") and there exists
  922.                  ;; no shorter key that would accept this,
  923.                  ;; then we will not recognize the key ("agent")
  924.                  ;; but this leads us to recognize in "?u?x" the
  925.                  ;; token "?u?" instead of "?"
  926.                    
  927.                  ;; if we are at the end of the string,
  928.                  ;; we accept
  929.                  (or (not find-id?)
  930.                      (not (< string-end string-length))
  931.                      ;; if a identifier-continue-char doesn't
  932.                      ;; follow, we also accept
  933.                      (not (identifier-continue-char-p
  934.                        (schar string string-end)))
  935.                      ;; if the key does not start with
  936.                      ;; an identifier-start-char we accept
  937.                      (not (identifier-start-char-p
  938.                        (schar terminal-token 0)))
  939.                      ;; if any of the remaining chars of the key
  940.                      ;; is not a identifier-continue-char,
  941.                      ;; we also accept
  942.                      (find-if-not #'identifier-continue-char-p
  943.                           terminal-token
  944.                           :start 1))))
  945.               (return-from recognize-kwd-aux
  946.                 (values token-association token-length)))))))))
  947.       (recognize-kwd-aux
  948.        (svref *terminal-alist-SEQ*
  949.           (char-code (if *case-sensitive*
  950.                  (the character (schar string pos))
  951.                (char-downcase (the character (schar string pos))))))))))
  952. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  953. ;;                                file-parser 
  954. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  955. ;; parse expressions in GRAMMAR reading from FILE
  956. ;; returns: a list of the parse-results, i.e. what would have been 
  957. ;;          returned by read-parser
  958.  
  959. (defvar *comment-brackets* '(("#|" . "|#")) )
  960. (defvar *comment-start* #\; )
  961.  
  962. (defun file-parser (file &key 
  963.              (error-fn #'error)
  964.              (print-parse-errors t)
  965.              (grammar *current-grammar*)
  966.              (verbose *load-verbose*))
  967.   (with-open-file (s (merge-pathnames file) :direction :input)
  968.     (file-parser-aux s error-fn print-parse-errors grammar verbose)))
  969.  
  970. (defun file-parser-aux (stream error-fn print-parse-errors grammar verbose
  971.              &aux R (eof (cons nil nil)))
  972.   (labels ((skip-lines (stream end)
  973.          ;; ignore lines until end is found
  974.          (let ((l (read-line stream nil eof)))
  975.            (if (stringp l)
  976.            (let ((p (search end l)))
  977.              (if p
  978.              (let ((l-rest (string-left-trim
  979.                     '(#\Space #\Tab)
  980.                     (subseq l (+ p (length end))))))
  981.                (if (string= l-rest "")
  982.                    (next-line stream)
  983.                  l-rest))
  984.                (skip-lines stream end)))
  985.          l)))
  986.        (next-line (stream)        ; ignore comments
  987.          (let ((l (read-line stream nil eof)))
  988.            (when verbose (terpri) (princ l))
  989.            (if (stringp l)
  990.            (let ((l-length (length (setq l (string-left-trim
  991.                             '(#\Space #\Tab) l)))))
  992.              (if (zerop l-length)
  993.              (next-line stream)
  994.                (if (char= *comment-start* (schar l 0))
  995.                (next-line stream)
  996.              ;; does this line start a comment
  997.              (dolist (comment *comment-brackets* l)
  998.                (let* ((start (car comment))
  999.                   (start-length (length start)))
  1000.                  (when (and
  1001.                     (>= l-length start-length)
  1002.                     (string= l start :end1 start-length))
  1003.                    ;; a comment found
  1004.                    (return
  1005.                  (setq l (skip-lines
  1006.                       stream
  1007.                       (cdr comment))))))))))
  1008.          l))))
  1009.     (do ((line (next-line stream)))
  1010.     ((eq line eof) (nreverse R))
  1011.       (multiple-value-bind (expr rest)
  1012.       (read-parser line
  1013.                :error-fn error-fn
  1014.                :print-parse-errors print-parse-errors
  1015.                :grammar grammar
  1016.                :junk-allowed t
  1017.                :more-allowed t
  1018.                :more-fn #'(lambda (&optional error-fn)
  1019.                     (setq line (next-line stream))
  1020.                     (if (eq line eof)
  1021.                     (if error-fn
  1022.                         (funcall error-fn)
  1023.                       (error "Reached end of file ~S while parsing"
  1024.                            stream))
  1025.                       line)))
  1026.     ;; (when verbose (let ((*print-structure* t)) (print expr)))
  1027.     (push expr R)
  1028.     (when (eq line eof) (return (nreverse R)))
  1029.     (setq line (if rest
  1030.                (subseq line rest)
  1031.              (next-line stream)))))))
  1032.  
  1033. ;----------------------------------------------------------------------------;
  1034. ; debug-parser
  1035. ;-------------
  1036. ; 
  1037. ; 
  1038. (defun debug-parser (&key (grammar t) (lexer nil))
  1039.   (setq *grammar-debug* grammar
  1040.     *lexer-debug* lexer)
  1041.   (let ((*default-pathname-defaults*
  1042.      (if (or grammar lexer)
  1043.          (merge-pathnames
  1044.           *ZEBU-directory*
  1045.           (make-pathname :type (first *load-source-pathname-types*)))
  1046.        (merge-pathnames
  1047.         (make-pathname
  1048.          :type (first *load-binary-pathname-types*))
  1049.         *ZEBU-binary-directory*))))
  1050.     (load "zebu-driver")))
  1051.  
  1052. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1053. ;;                             End of zebu-driver.lisp
  1054. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1055.